home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)Z / (A)Z11.ADF / LOGO / LOGOSOURCE / logoproc.c < prev    next >
C/C++ Source or Header  |  1987-06-29  |  12KB  |  600 lines
  1.  
  2. #include "logo.h"
  3. #ifdef AMIGA
  4. #include <errno.h>
  5. #endif
  6.  
  7. int errrec();
  8. int ehand2();
  9. int ehand3();
  10. int leave();
  11.  
  12. extern char popname[];
  13. extern int letflag, pflag, argno, yyline, rendflag, currtest;
  14. extern int traceflag, *stkbase, stkbi, yychar, endflag, topf;
  15. #ifdef PAUSE
  16. extern int pauselev, errpause, catching, flagquit;
  17. #endif
  18. #ifndef NOTURTLE
  19. extern int turtdes;
  20. #endif
  21. extern char *ckzmalloc(), charib, *getbpt, *ibufptr;
  22. extern char titlebuf[];
  23. extern struct lexstruct keywords[];
  24. extern struct stkframe *fbr;
  25. extern struct plist *proclist;
  26. extern struct object *multarg;
  27. extern struct runblock *thisrun;
  28. #ifndef YYSTYPE
  29. #define YYSTYPE int
  30. #endif
  31. extern YYSTYPE yylval;
  32.  
  33. int doprep = 0;
  34. int *newstk =NULL;
  35. int newsti =0;
  36. FILE *pbuf =0;
  37. struct plist *pcell =NULL;
  38. struct alist *locptr =NULL, *newloc =NULL;
  39. struct object *allocstk[MAXALLOC] ={0};
  40.  
  41. int memb(ch,str)
  42. register char ch,*str;
  43. {
  44.     register char ch1;
  45.  
  46.     while (ch1 = *str++)
  47.         if (ch == ch1) return(1);
  48.     return(0);
  49. }
  50.  
  51. char *token(str)
  52. register char *str;
  53. {
  54.     static char output[NAMELEN+5];
  55.     register char ch,*op;
  56.  
  57.     op = output;
  58.     while((op < &output[19]) && (ch = *str++) && !memb(ch," \t\"[\r\n:")){
  59.         if (ch >= 'A' && ch <= 'Z') ch += 'a'-'A';
  60.         *op++ = ch;
  61.     }
  62.     *op = '\0';
  63.     return(output);
  64. }
  65.  
  66. #ifdef DEBUG
  67. jfree(block)
  68. char *block;
  69. {
  70.     if (memtrace)
  71.         printf("Jfree loc=0%o\n",block);
  72.     if (block==0) printf("Trying to jfree zero.\n");
  73.     else free(block);
  74. }
  75. #endif
  76.  
  77. newproc(nameob)
  78. struct object *nameob;
  79. {
  80.     register char *name;
  81.     register struct stkframe *stemp;
  82.     register struct lincell *ltemp;
  83.     struct plist *pptr;
  84.     int linlab;
  85.     int itemp;
  86.     char *temp,*tstr;
  87.     struct object *title;
  88.     char s[100];
  89.     int olp;
  90.     int oldlet;
  91.     int olc,c;
  92.     int pc;
  93.     extern struct plist *proclook();
  94.  
  95.     name = nameob->obstr;
  96.     stemp=(struct stkframe *)ckzmalloc(sizeof(*stemp));
  97.     stemp->prevframe=fbr;
  98.     stemp->oldyyc= -2;
  99.     stemp->oldline= -1;
  100.     stemp->oldnewstk=newstk;
  101.     newstk = NULL;
  102.     stemp->oldnloc=newloc;
  103.     newloc=NULL;
  104.     stemp->argtord=argno;
  105.     stemp->prevpcell=pcell;
  106.     pcell = NULL;
  107.     stemp->loclist = NULL;
  108.     fbr=stemp;
  109.     doprep++;
  110.     argno=0;
  111.     if (pptr=proclook(name)) {
  112.         mfree(nameob);
  113.         newstk=pptr->realbase;
  114.         (pptr->recdepth)++;
  115.         title=pptr->ptitle;
  116.         pcell=pptr;
  117.     } else {
  118.         onintr(ehand2,&pbuf);
  119.         cpystr (s,name,EXTEN,NULL);
  120.         if (!(pbuf=fopen(s,"r"))) {
  121.             extern int errno;
  122.  
  123.             if (errno != ENOENT) /* ENOENT */ {
  124.                 onintr(errrec,1);
  125. #ifdef SMALL
  126.                 printf("%s: error %d\n",s,errno);
  127. #else
  128.                 perror(s);
  129. #endif
  130.                 errhand();
  131.             }
  132.             cpystr(s,LIBLOGO,name,EXTEN,NULL);
  133.             if (!(pbuf = fopen(s,"r"))) {
  134.                 onintr(errrec,1);
  135.                 printf("You haven't told me how to %s.\n",name);
  136.                 errhand();
  137.             }
  138.         }
  139.         pptr=(struct plist *)ckzmalloc(sizeof(*pptr));
  140.         pptr->plines=NULL;
  141.         pptr->procname=globcopy(nameob);
  142.         mfree(nameob);
  143.         temp=s;
  144.         while ( ((c=getc(pbuf)) != EOF) && (c!='\n') ) *temp++=c;
  145.         if (c==EOF) {
  146.             printf("Bad format in %s title line.\n",
  147.                 pptr->procname->obstr);
  148.             errhand();
  149.         }
  150.         *temp++='\n';
  151.         *temp='\0';
  152.         title=globcopy(objcpstr(s));
  153.         pptr->after=proclist;
  154.         pptr->recdepth=1;
  155.         pptr->ptitle=title;
  156.         pptr->before=NULL;
  157.         if (proclist) proclist->before = pptr;
  158.         proclist=pptr;
  159.         pcell=pptr;
  160.     }
  161.     tstr = title->obstr;
  162. nextarg: while((c= *tstr++)!=':' && c!='\n')
  163.         ;
  164.     if (c==':') {
  165.         temp=s;
  166.         while ((c= *tstr++)!=' ' && c!='\n') *temp++=c;
  167.         *temp='\0';
  168.         tstr--;
  169.         loccreate(globcopy(objcpstr(s)),&newloc);
  170.         argno++;
  171.         goto nextarg;
  172.     }
  173.     if (pptr->recdepth!=1) return;
  174.     olp=pflag;
  175.     pflag=1;
  176.     oldlet=letflag;
  177.     letflag=0;
  178.     olc=charib;
  179.     charib=0;
  180.     newstk=(int *)ckmalloc(PSTKSIZ*sizeof(int));
  181.     *newstk=0;
  182.     newsti=1;
  183.     *(newstk+newsti) = -1;    /* BH 6/25/82 in case yylex blows up */
  184.     itemp = '\n';
  185.     while ((pc = yylex()) != -1) {
  186.         if (pc==1) return;
  187.         if ((itemp == '\n') && isuint(pc)) {
  188.             linlab=((struct object *)yylval)->obint;
  189.             ltemp=(struct lincell *)ckmalloc(sizeof(*ltemp));
  190.             ltemp->linenum=linlab;
  191.             ltemp->base=newstk;
  192.             ltemp->index=newsti;
  193.             ltemp->nextline=pptr->plines;
  194.             pptr->plines=ltemp;
  195.         }
  196.         *(newstk+newsti++)=pc;
  197.         if (newsti==PSTKSIZ-1) newfr();
  198.         *(newstk+newsti++)=yylval;
  199.         if (isstored(pc)) {
  200.             yylval = (YYSTYPE)globcopy(yylval);
  201.             mfree(yylval);
  202.         }
  203.         if (newsti==PSTKSIZ-1) newfr();
  204.         *(newstk+newsti) = -1;
  205.         itemp = pc;
  206.     }
  207.     *(newstk+newsti)= -1;
  208.     *(newstk+PSTKSIZ-1)=0;
  209.     pflag=olp;
  210.     letflag=oldlet;
  211.     charib=olc;
  212.     fclose(pbuf);
  213.     onintr(errrec,1);
  214.     while (*newstk!=0) newstk= (int *)*newstk;
  215.     pptr->realbase=newstk;
  216. }
  217.  
  218. procprep()
  219. {
  220.     doprep=0;
  221.     fbr->oldline=yyline;
  222.     fbr->oldbpt=getbpt;
  223.     getbpt=0;
  224.     fbr->loclist=locptr;
  225.     locptr=newloc;
  226.     newloc=NULL;
  227.     fbr->stk=stkbase;
  228.     stkbase=newstk;
  229.     newstk=NULL;
  230.     fbr->ind=stkbi;
  231.     stkbi=1;
  232.     newsti=0;
  233.     argno= -1;
  234.     fbr->oldpfg = pflag;
  235.     pflag=2;
  236.     fbr->iftest = currtest;
  237.     if (traceflag) intrace();
  238. }
  239.  
  240. frmpop(val)
  241. register struct object *val;
  242. {
  243.     struct alist *atemp0,*atemp1,*atemp2;
  244.     register struct stkframe *ftemp;
  245.     struct lincell *ltemp,*ltemp2;
  246.     register i;
  247.     int *stemp;
  248.     int stval;
  249.  
  250.     if (traceflag) outtrace(val);
  251.     if (!pcell) goto nopcell;
  252.     strcpy(popname,pcell->procname->obstr);
  253.     (pcell->recdepth)--;
  254.     if (pcell->recdepth==0) {
  255.         lfree(pcell->procname);
  256.         lfree(pcell->ptitle);
  257.         if (pcell->before) (pcell->before)->after=pcell->after;
  258.         else proclist=pcell->after;
  259.         if (pcell->after) (pcell->after)->before=pcell->before;
  260.         for(ltemp=pcell->plines;ltemp;ltemp=ltemp2) {
  261.             ltemp2=ltemp->nextline;
  262.             JFREE(ltemp);
  263.         }
  264.         if ((stemp=stkbase) == 0) goto nostack;
  265.         while (*stemp!=0) stemp= (int *)*stemp;
  266.         for (i=1;;i++) {
  267.             stval= *(stemp+i);
  268.             if (isstored(stval))
  269.             {
  270.                 if (i==PSTKSIZ-2) {
  271.                     stkbase= (int *)*(stemp+PSTKSIZ-1);
  272.                     JFREE(stemp);
  273.                     stemp=stkbase;
  274.                     i=0;
  275.                 }
  276.                 lfree(*(stemp+ (++i)));
  277.             } else if (stval== -1) {
  278.                 JFREE(stemp);
  279.                 break;
  280.             } else {
  281.                 if (i==PSTKSIZ-2) {
  282.                     stkbase= (int *)*(stemp+PSTKSIZ-1);
  283.                     JFREE(stemp);
  284.                     stemp=stkbase;
  285.                     i=1;
  286.                 } else i++;
  287.             }
  288.             if (i==PSTKSIZ-2) {
  289.                 stkbase= (int *)*(stemp+PSTKSIZ-1);
  290.                 JFREE(stemp);
  291.                 stemp=stkbase;
  292.                 i=0;
  293.             }
  294.         }
  295.     nostack:
  296.         JFREE(pcell);
  297.     }
  298. nopcell:
  299.     ftemp=fbr;
  300.     stkbase=ftemp->stk;
  301.     stkbi=ftemp->ind;
  302.     newstk=ftemp->oldnewstk;
  303.     atemp0=newloc;    /* BH 6/20/82 maybe never did procprep */
  304.     newloc=ftemp->oldnloc;
  305.     pflag = fbr->oldpfg;
  306.     atemp1=locptr;
  307.     locptr=ftemp->loclist;
  308.     argno=ftemp->argtord;
  309.     pcell=ftemp->prevpcell;
  310.     yychar=ftemp->oldyyc;
  311.     yylval=ftemp->oldyyl;
  312.     yyline=ftemp->oldline;
  313.     getbpt=ftemp->oldbpt;
  314.     currtest=ftemp->iftest;
  315.     fbr=ftemp->prevframe;
  316.     JFREE(ftemp);
  317.     while (atemp1) {
  318.         atemp2=atemp1->next;
  319.         if (atemp1->name) lfree(atemp1->name);
  320.         if (atemp1->val!=(struct object *)-1)    /* BH 2/28/80 was NULL instead of -1 */
  321.             lfree(atemp1->val);
  322.         JFREE(atemp1);
  323.         atemp1=atemp2;
  324.     }
  325.     while (atemp0) {
  326.         atemp2=atemp0->next;
  327.         if (atemp0->name) lfree(atemp0->name);
  328.         if (atemp0->val!=(struct object *)-1)
  329.             lfree(atemp0->val);
  330.         JFREE(atemp0);
  331.         atemp0=atemp2;
  332.     }
  333. }
  334.  
  335. proccreate(nameob)
  336. register struct object *nameob;
  337. {
  338.     register char *name;
  339.     char temp[16];
  340.     register FILDES edfd;
  341.     int pid;
  342.  
  343. #ifndef NOTURTLE
  344.     if (turtdes<0) textscreen();
  345. #endif
  346.     name = token(nameob->obstr);
  347.     if (strlen(name)>NAMELEN) {
  348.         pf1("Procedure name must be no more than %d letters.",NAMELEN);
  349.         errhand();
  350.     }
  351.     cpystr(temp,name,EXTEN,NULL);
  352.     if ((edfd=open(temp,READ,0))>=0) {
  353.         close(edfd);
  354.         nputs(name);
  355.         puts(" is already defined.");
  356.         errhand();
  357.     }
  358.     if ((edfd = creat(temp,0666)) < 0) {
  359.         printf("Can't write %s.\n",name);
  360.         errhand();
  361.     }
  362.     onintr(ehand3,edfd);
  363.     mfree(nameob);
  364.     write(edfd,titlebuf,strlen(titlebuf));
  365.     addlines(edfd);
  366.     onintr(errrec,1);
  367. }
  368.  
  369. help()
  370. {
  371.     FILE *sbuf;
  372.  
  373.     sbuf=fopen(HELPFILE,"r");
  374.     if (sbuf == NULL) {
  375.         printf("? Help file missing, sorry.\n");
  376.         return;
  377.     }
  378.     onintr(ehand2,sbuf);
  379.     while(putch(getc(sbuf))!=EOF)
  380.         ;
  381.     fclose(sbuf);
  382.     onintr(errrec,1);
  383. }
  384.  
  385. struct object *describe(arg)
  386. struct object *arg;
  387. {
  388.     register char *argstr;
  389.     register struct lexstruct *lexp;
  390.     FILE *sbuf;
  391.     char fname[30];
  392.  
  393.     if (!stringp(arg)) ungood("Describe",arg);
  394.     argstr = token(arg->obstr);
  395.     for (lexp = keywords; lexp->word; lexp++)
  396.          if (!strcmp(argstr,lexp->word) || 
  397.              (lexp->abbr && !strcmp(argstr,lexp->abbr)))
  398.             break;
  399.     if (!lexp->word) {
  400.         pf1("%p isn't a primitive.\n",arg);
  401.         errhand();
  402.     }
  403.     if (strlen(lexp->word) > 9)    /* kludge for Eunice */
  404.         cpystr(fname,DOCLOGO,lexp->abbr,NULL);
  405.     else
  406.         cpystr(fname,DOCLOGO,lexp->word,NULL);
  407.     if (!(sbuf=fopen(fname,"r"))) {
  408.         printf("Sorry, I have no information about %s\n",lexp->word);
  409.         errhand();
  410.     } else {
  411.         onintr(ehand2,sbuf);
  412.         while (putch(getc(sbuf))!=EOF)
  413.             ;
  414.         fclose(sbuf);
  415.     }
  416.     onintr(errrec,1);
  417.     mfree(arg);
  418.     return ((struct object *)(-1));
  419. }
  420.  
  421. errwhere()
  422. {
  423.     register i =0;
  424.     register struct object **astk;
  425.     register struct plist *opc;
  426.  
  427.     cboff();    /* BH 12/13/81 */
  428.     ibufptr=NULL;
  429.     if (doprep) {
  430.         procprep();
  431.         frmpop(-1);
  432.     }
  433.  
  434.     for (astk=allocstk;i<MAXALLOC;i++)
  435.         if (astk[i]!=0)
  436.             mfree(astk[i]);
  437.  
  438.     if (multarg) {
  439.         lfree(multarg);
  440.         multarg = 0;
  441.     }    /* BH 10/31/81 multarg isn't on astk, isn't mfreed. */
  442.  
  443. #ifdef PAUSE
  444.     if ((errpause||pauselev) && fbr && !topf) {
  445.         /* I hope this pauses on error */
  446.         if (!pflag && !getbpt) charib=0;
  447.         dopause();
  448.     }
  449.     else
  450. #endif
  451.     {
  452.         opc = pcell;
  453.         if (fbr && fbr->oldline==-1) {
  454.             opc=fbr->prevpcell;
  455.         }
  456.         if (opc&&!topf)
  457.             printf("You were at line %d in procedure %s\n",
  458.                 yyline,opc->procname->obstr);
  459.     }
  460. }
  461.  
  462. errzap() {
  463.     while (thisrun)
  464.         unrun();
  465.  
  466.     while (fbr)
  467.         frmpop(-1);
  468.  
  469.     charib=0;
  470.     if(traceflag)traceflag=1;
  471.     topf=0;
  472.     yyline=0;
  473.     letflag=0;
  474.     pflag=0;
  475.     endflag=0;
  476.     rendflag=0;
  477.     argno= -1;
  478.     newstk=NULL;
  479.     newsti=0;
  480.     stkbase=NULL;
  481.     stkbi=0;
  482.     fbr=NULL;
  483.     locptr=NULL;
  484.     newloc=NULL;
  485.     proclist=NULL;
  486.     pcell=NULL;
  487. #ifdef PAUSE
  488.     pauselev = 0;
  489. #endif
  490. }
  491.  
  492. errrec()
  493. {
  494.     /* Here on SIGQUIT */
  495. #ifdef PAUSE
  496.     if (catching)
  497. #endif
  498.         errhand();
  499. #ifdef PAUSE
  500.     flagquit++;    /* We'll catch this later */
  501. #endif
  502. }
  503.  
  504. ehand2(fle)
  505. register FILE *fle;
  506. {
  507.     fclose(fle);
  508.     errhand();
  509. }
  510.  
  511. ehand3(fle)
  512. register FILDES fle;
  513. {
  514.     close(fle);
  515.     errhand();
  516. }
  517.  
  518. struct object *tracefuns = 0;
  519.  
  520. ltrace() {    /* trace everything */
  521.     lfree(tracefuns);
  522.     tracefuns = (struct object *)0;
  523.     traceflag = 1;
  524. }
  525.  
  526. luntrace() {    /* trace nothing */
  527.     lfree(tracefuns);
  528.     tracefuns = (struct object *)0;
  529.     traceflag = 0;
  530. }
  531.  
  532. struct object *sometrace(funs)
  533. struct object *funs;
  534. {
  535.     if (funs==0) {
  536.         luntrace();
  537.     } else if (!listp(funs)) {
  538.         ungood("Trace",funs);
  539.     } else {
  540.         tracefuns = globcopy(funs);
  541.         mfree(funs);
  542.         traceflag = 1;
  543.     }
  544.     return ((struct object *)(-1));
  545. }
  546.  
  547. int chktrace(procname)
  548. char *procname;
  549. {
  550.     struct object *rest;
  551.  
  552.     if (tracefuns == 0) return(1);
  553.     for (rest=tracefuns; rest; rest=rest->obcdr) {
  554.         if (!stringp(rest->obcar)) continue;
  555.         if (!strcmp(token(rest->obcar->obstr),procname)) return(1);
  556.     }
  557.     return(0);
  558. }
  559.  
  560. intrace()
  561. {
  562.     register struct alist *aptr;
  563.  
  564.     if (!pcell) return;
  565.     if (!chktrace(pcell->procname->obstr)) return;
  566.     indent(traceflag-1);
  567.     nputs(pcell->procname->obstr);
  568.     if (locptr && (locptr->val != (struct object *)-1)) {
  569.         pf1(" of %l",locptr->val);    /* BH locptr->val was inval */
  570.         for (aptr=locptr->next;aptr;aptr=aptr->next) {
  571.             if (aptr->val == (struct object *)-1) break;
  572.             pf1(" and %l",aptr->val);    /* was inval */
  573.         }
  574.         putchar('\n');
  575.     }
  576.     else puts(" called.");
  577.     fflush(stdout);
  578.     traceflag++;
  579. }
  580.  
  581. outtrace(retval)
  582. register struct object *retval;
  583. {
  584.     if (!pcell) return;
  585.     if (!chktrace(pcell->procname->obstr)) return;
  586.     if (traceflag>1) traceflag--;
  587.     indent(traceflag-1);
  588.     nputs(pcell->procname->obstr);
  589.     if (retval != (struct object *)-1) pf1(" outputs %l\n",retval);
  590.     else puts(" stops.");
  591.     fflush(stdout);
  592. }
  593.  
  594. indent(no)
  595. register int no;
  596. {
  597.     while (no--)putchar(' ');
  598. }
  599.  
  600.